home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / w3 / w3-epoch.el < prev    next >
Encoding:
Text File  |  1995-08-29  |  12.7 KB  |  387 lines
  1. ;;; w3-epoch.el,v --- Epoch 4.x specific functions for emacs-w3
  2. ;; Author: wmperry
  3. ;; Created: 1995/08/25 01:05:49
  4. ;; Version: 1.33
  5. ;; Keywords: faces, help, mouse, hypermedia
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
  9. ;;;
  10. ;;; This file is part of GNU Emacs.
  11. ;;;
  12. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;;; it under the terms of the GNU General Public License as published by
  14. ;;; the Free Software Foundation; either version 2, or (at your option)
  15. ;;; any later version.
  16. ;;;
  17. ;;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;;; GNU General Public License for more details.
  21. ;;;
  22. ;;; You should have received a copy of the GNU General Public License
  23. ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  24. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ;;; Epoch Enhancements
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30.  
  31. ;; This is necessary for buffer-styles to work correctly
  32. (setq w3-persistent-variables (cons 'buffer-style w3-persistent-variables))
  33.  
  34. (defvar w3-style-cache nil "Mapping of face names to style objects")
  35.  
  36. (defun find-face (name)
  37.   (assq name w3-style-cache))
  38.  
  39. (defun make-face (new-name &optional def-fn def-fg def-bg def-ulp)
  40.   (or (find-face new-name)
  41.       (let* ((face (make-style))
  42.          (name (symbol-name new-name))
  43.          (fn   (or (w3-get-resource (concat name ".attributeFont")
  44.                     "Face.AttributeFont") def-fn))
  45.          (fg   (or (w3-get-resource (concat name ".attributeForeground")
  46.                     "Face.AttributeForeground") def-fg))
  47.          (bg   (or (w3-get-resource (concat name ".attributeBackground")
  48.                     "Face.AttributeBackground") def-bg))
  49.          (ulp  (or (w3-get-resource (concat name ".attributeUnderline")
  50.                     "Face.AttributeUnderline") def-ulp)))
  51.     (if fn
  52.         (condition-case ()
  53.         (set-style-font face fn)
  54.           (error (w3-warn 'faces
  55.                   (format "Font `%s' not found for face `%s'"
  56.                       fn name)))))
  57.     (if fg
  58.         (condition-case ()
  59.         (set-style-foreground face fg)
  60.           (error (w3-warn 'faces "Color `%s' not allocated for face `%s'"
  61.                   fg name))))
  62.     (if bg
  63.         (condition-case ()
  64.         (set-style-background face bg)
  65.           (error (w3-warn 'faces "Color `%s' not allocated for face `%s'"
  66.                   bg name))))
  67.     (if (and
  68.          (stringp ulp)
  69.          (member (downcase ulp) '("true" "on" "yes" "t")))
  70.         (set-style-underline face "white"))
  71.     (setq w3-style-cache (cons (cons new-name face) w3-style-cache)))))
  72.  
  73. (defun face-list ()
  74.   (mapcar 'car w3-style-cache))
  75.  
  76. (defun face-instance (face)
  77.   (cdr-safe (assq face w3-style-cache)))
  78.  
  79. (defun set-face-font (face font)
  80.   (let ((style (cdr-safe (assq face w3-style-cache))))
  81.     (and style (set-style-font font))))
  82.  
  83. (defun set-face-foreground (face color)
  84.   (let ((style (cdr-safe (assq face w3-style-cache))))
  85.     (and style (set-style-foreground style color))))
  86.  
  87. (defun set-face-background (face color)
  88.   (let ((style (cdr-safe (assq face w3-style-cache))))
  89.     (and style (set-style-background style color))))
  90.  
  91. (defun w3-create-faces ()
  92.   "Create the faces, the Epoch way"
  93.   (make-face 'bold nil "green" nil nil)
  94.   (make-face 'italic nil "pink" nil nil)
  95.   (make-face 'bold-italic nil "springgreen" nil nil)
  96.   (make-face 'w3-node-style nil "yellow" nil t)
  97.   (make-face 'w3-default-style nil nil nil nil)
  98.   (make-face 'w3-visited-node-style nil "red" nil nil))
  99.  
  100. (defvar w3-mouse-map (create-mouse-map))
  101. (define-key w3-mode-map "i" 'w3-load-delayed-images)
  102.  
  103. (defun w3-find-specific-link (link)
  104.   "Find LINK in the current document"
  105.   (let* ((thezones (epoch::zones-in-region (point-min) (point-max))))
  106.     (while (and thezones
  107.         (not (equal link
  108.                 (car-safe
  109.                  (cdr (epoch::zone-data (car thezones)))))))
  110.       (setq thezones (cdr thezones)))
  111.     (if thezones
  112.     (goto-char (zone-start (car thezones)))
  113.       (message "Link %s was not found." link))))
  114.  
  115. (fset 'w3-delete-zone 'epoch::delete-zone)
  116. (fset 'w3-zone-data 'epoch::zone-data)
  117. (fset 'w3-zone-start 'epoch::zone-start)
  118. (fset 'w3-zone-end 'epoch::zone-end)
  119. (fset 'w3-zone-eq 'eq)
  120. (fset 'w3-zone-at 'epoch::zone-at)
  121.  
  122. (defun w3-extend-zone (zone pt)
  123.   (epoch::move-zone zone (zone-start zone) pt))
  124.  
  125. (defun w3-zone-hidden-p (start end)
  126.   "Return t iff the region from start to end is invisible."
  127.   nil)
  128.  
  129. (defun w3-unhide-zone (start end)
  130.   "Make a region from START TO END visible. (epoch-unfunctional)"
  131.   nil)
  132.  
  133. (defun w3-hide-zone (start end)
  134.   "Make a region from START to END invisible. (epoch-nonfunctional)"
  135.   nil)
  136.  
  137. (defun w3-all-zones ()
  138.   "Return all the zones in this buffer."
  139.   (epoch::zones-in-region (point-min) (point-max)))
  140.  
  141. (defun w3-forward-link (p)
  142.   "Go forward 1 link"
  143.   (interactive "P")
  144.   (setq p (or p 1))
  145.   (if (< p 0)
  146.       (w3-back-link (- p))
  147.     (if (/= 1 p)
  148.     (w3-forward-link (1- p)))
  149.     (let* ((thezones (epoch::zones-in-region 
  150.               (if (epoch::zone-at (point))
  151.               (1+ (epoch::zone-end (epoch::zone-at (point))))
  152.             (point)) (point-max))))
  153.       (while (and thezones
  154.           (not (memq (car (epoch::zone-data (car thezones)))
  155.                  '(w3 w3form))))
  156.     (setq thezones (cdr thezones)))
  157.       (if (car thezones)
  158.       (goto-char (epoch::zone-start (car thezones)))))))
  159.  
  160. (defun w3-back-link (p)
  161.   "Go back 1 link"
  162.   (interactive "P")
  163.   (setq p (or p 1))
  164.   (if (< p 0)
  165.       (w3-forward-link (- p))
  166.     (if (/= 1 p)
  167.     (w3-back-link (1- p)))
  168.     (let* ((thezones (epoch::zones-in-region
  169.               (point-min)
  170.               (if (epoch::zone-at (point))
  171.               (1- (epoch::zone-start (epoch::zone-at (point))))
  172.             (point)))))
  173.       (while (and thezones
  174.           (and
  175.            (equal (car-safe (epoch::zone-data (car (last thezones))))
  176.               'w3)
  177.            (memq (cdr-safe (epoch::zone-data (car (last thezones))))
  178.              '(style address header))))
  179.     (setq thezones (butlast thezones 1)))
  180.       (if (car thezones)
  181.       (goto-char (epoch::zone-start (car (last thezones))))))))
  182.  
  183. (defun w3-follow-mouse (mouse-data)
  184.   "Follow the link under the mouse cursor"
  185.   (interactive)
  186.   (mouse::set-point mouse-data)
  187.   (w3-follow-link))
  188.  
  189. (defun w3-fix-extent-endpoints ()
  190.   "Make sure no extents have whitespace at the end of them."
  191.   (let ((x (epoch::zones-in-region (point-min) (point-max))))
  192.     (while x
  193.       (let ((st (epoch::zone-start (car x)))
  194.         (nd (epoch::zone-end (car x))))
  195.     (while (memq (char-after (1- nd)) '(?\t ?\r ?\n ?\ ))
  196.       (setq nd (1- nd)))
  197.     (while (memq (char-after st) '(?\t ?\r ?\n ?\ ))
  198.       (setq st (1+ st)))
  199.     (epoch::move-zone (car x) st nd))
  200.       (setq x (cdr x)))))
  201.  
  202. (defun w3-follow-link ()
  203.   "Attempt to follow link under cursor"
  204.   (interactive)
  205.   (let ((x (zones-in-region (point) (if (= (point) (point-max)) (point-max)
  206.                       (1+ (point))) t))
  207.     (data nil))
  208.     (if x
  209.     (progn
  210.       (while x
  211.         (setq data (epoch::zone-data (car x)))
  212.         (if (eq (car-safe data) 'w3form)
  213.         (w3-do-form-entry data (car x))
  214.           (if (and (equal (car-safe data) 'w3)
  215.                (not (memq (car (cdr data))
  216.                   '(address header style pic))))
  217.           (url-maybe-relative (car (cdr (cdr data))))))
  218.         (setq x (cdr x))))
  219.       (progn
  220.     (setq x (zone-at (point)))
  221.     (if x
  222.         (progn
  223.           (setq data (zone-data x))
  224.           (if (eq (car-safe data) 'w3form) (w3-do-form-entry data x)
  225.         (if (and (equal (car-safe data) 'w3)
  226.              (not (memq (car (cdr data))
  227.                     '(address header style pic))))
  228.             (url-maybe-relative (car (cdr (cdr data)))))))
  229.       (message "Not on a link!"))))))
  230.  
  231. (defun w3-add-zone (start end style data &optional highlight)
  232.   "Add highlighting (epoch)"
  233.   (cond
  234.    ((stylep style) nil)
  235.    ((symbolp style)
  236.     (setq style (cdr-safe (assq style w3-style-cache)))) 
  237.    (t (setq style nil)))
  238.   (let ((zone (add-zone start end style)))
  239.     (epoch::set-zone-data zone data)
  240.     zone))
  241.  
  242. (define-mouse w3-mouse-map mouse-middle mouse-down 'w3-follow-mouse)
  243.  
  244. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  245. ;;; Graphics handling
  246. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  247. (if (and (fboundp 'add-graphic-zone)
  248.      (fboundp 'epoch::read-pixmap-file))
  249.     (defun w3-insert-graphic (name pt align alt)
  250.       "Insert the graphic pointed to by the URL NAME, at buffer position POINT,
  251. with alignment specified by ALIGN (one of 'center 'top or 'bottom).  If the
  252. conversion of the picture fails for any reason, use ALT as the alternative
  253. text.  If the reading of the pixmap is successful, the url and a pointer to
  254. the pixmap are stored in w3-graphics-list for possible re-use later.
  255.  
  256.   If I can ever figure out how to get the color _NAME_ from epoch, I will
  257. change this to grok bitmaps/pixmaps and change their background color to
  258. that of the emacs screen.  Will look better that way.
  259.  
  260.   If epoch was not compiled with graphics zone support, this function
  261. does nothing."
  262.       (goto-char pt)
  263.       (insert "^")
  264.       (let ((bit nil)
  265.         (converter nil)
  266.         (add-to-list nil)
  267.         (lnk (cdr name))
  268.         (url-request-method "GET")
  269.         (url-be-asynchronous nil)
  270.         (url-request-data nil)
  271.         (url-mime-accept-string nil)
  272.         (w3-source t)
  273.         (url-request-extra-headers nil)
  274.         (fname (url-generate-unique-filename)))
  275.     (setq name (car name)
  276.           url-mime-accept-string
  277.           (substring
  278.            (mapconcat
  279.         (function
  280.          (lambda (x)
  281.            (if x (concat (car x) ",") ""))) w3-graphic-converter-alist
  282.            "")
  283.            0 -1))
  284.     (save-excursion
  285.       (let ((w3-working-buffer " *W3GRAPH*"))
  286.         (if (assoc name w3-graphics-list)
  287.         (progn
  288.           (message "Reusing image...")
  289.           (setq bit (cdr (assoc name w3-graphics-list))))
  290.           (progn
  291.         (url-retrieve name)
  292.         (setq add-to-list t)
  293.         (w3-convert-graphic-to-useable-format w3-working-buffer
  294.                               fname
  295.                               nil)
  296.         (message "Reading image %s..." url-current-file)
  297.         (condition-case ()
  298.             (setq bit (epoch::read-pixmap-file fname))
  299.           (error nil))
  300.         (condition-case ()
  301.             (delete-file fname)
  302.           (error nil))))))
  303.     (and add-to-list
  304.          (setq w3-graphics-list
  305.            (cons (cons name bit) w3-graphics-list)))
  306.     (if bit
  307.         (add-graphic-zone bit pt (1+ pt)
  308.                   (cond
  309.                    ((eq align 'top) 0)
  310.                    ((eq align 'center) 50)
  311.                    ((eq align 'bottom) 100)
  312.                    (t 50))
  313.                   '(w3 pic) (current-buffer))
  314.       (progn
  315.         (goto-char pt)
  316.         (delete-region pt (1+ pt))
  317.         (insert alt)
  318.         (w3-add-zone pt (point) nil (list 'w3graphic name) t))))))
  319.  
  320. (defun w3-create-hrule ()
  321.   "Create a pixmap that is the width of the current buffer.  This
  322. could use some work - not extremely pretty right now, but it works.
  323.  
  324.   If epoch was not compiled with graphics zone support, this function
  325. returns nil, causing the function which calls it (w3-fix-horizontal-rules)
  326. to draw a line with dashes."
  327.   (if (not (fboundp 'read-pixmap-file)) nil
  328.   (let ((width (- (window-pixwidth) 10))
  329.     x bit f)
  330.     (setq x (concat "/* XPM */\nstatic char * scratch [] = {\n"
  331.             (format "\"%d 4 2 1\",\n" width)
  332.             (format "\"       c %s\",\n" "gray80") 
  333.             (format "\".      c %s\",\n" "black")
  334.             (format "\"%s\",\n" (make-string width 32))
  335.             (format "\"%s\",\n" (make-string width ?.))
  336.             (format "\"%s\",\n" (make-string width ?.))
  337.             (format "\"%s\"};\n" (make-string width 32)))
  338.       f (url-generate-unique-filename)
  339.       bit (progn
  340.         (save-excursion
  341.           (set-buffer (get-buffer-create " *tmp*"))
  342.           (erase-buffer)
  343.           (insert x)
  344.           (write-region (point-min) (point-max) f nil 5)
  345.           (kill-buffer " *tmp*")
  346.           (read-pixmap-file f))))
  347.     bit)))
  348.  
  349. (defun w3-insert (&rest args)
  350.   (let ((start (point))
  351.     (zones (zones-at (point))))
  352.     (prog1
  353.     (apply 'insert-before-markers args)
  354.       (mapcar (function (lambda (zone)
  355.               (if (equal (zone-start zone) start)
  356.                   (move-zone zone (point) (zone-end zone)))))
  357.           zones))))
  358.  
  359. (defun w3-setup-version-specifics ()
  360.   "Set up routine for Lucid emacs 19.9"
  361.   nil)
  362.  
  363. (fset 'w3-store-in-x-clipboard 'epoch::store-cut-buffer)
  364.  
  365. (defun w3-map-links (function &optional buffer from to maparg)
  366.   "Map FUNCTION over the hypertext links which overlap region in BUFFER,
  367. starting at FROM and ending at TO.  FUNCTION is called with the arguments
  368. linkdata, START, END, and MAPARG.
  369. The arguments FROM, TO, MAPARG, and BUFFER default to the beginning of
  370. BUFFER, the end of BUFFER, nil, and (current-buffer), respectively."
  371.   (mapcar (function
  372.        (lambda (x)
  373.          (if (eq (car (w3-zone-data x)) 'w3)
  374.          (funcall function (w3-zone-data x)
  375.               (w3-zone-start x)
  376.               (w3-zone-end x)
  377.               maparg))
  378.          nil)) (epoch::zones-in-region (or from (point-min))
  379.                        (or to (point-max))))
  380.   nil)
  381.  
  382. (defun w3-mode-version-specifics ()
  383.   "Epoch specific stuff for w3-mode"
  384.   (use-local-mouse-map w3-mouse-map))
  385.  
  386. (provide 'w3-epoch)
  387.